home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / defs.em < prev    next >
Lisp/Scheme  |  1993-07-15  |  12KB  |  406 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: defs.em
  4. ;; Date: Fri Jun 12 18:01:37 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule defs
  11.   ( macros0
  12.     (except (not) extras0)
  13.     (except (not) init)
  14.     )
  15.   ()
  16.   (defun not (x) (null x))
  17.   
  18.   ;; XXX: Boot problemette
  19.   ;; 'defstruct'...
  20.  
  21.   ;; Utils... 
  22.  
  23.   (defconstant *key-list-fail* nil)
  24.   ;;(defun not (x) (null x))
  25.  
  26.   (defconstant *nothing* (gensym))
  27.  
  28.   (defun search-key-list (l k)
  29.     (cond ((null l) *key-list-fail*)
  30.       ((eqcar l k) (cadr l))
  31.       (t (search-key-list (cddr l) k))))
  32.  
  33.   (defconstant invalid-slot-options nil)
  34.   '(make <condition-class>
  35.        'name 'invalid-slot-options
  36.        'direct-superclasses (list <condition>)
  37.        'direct-slot-descriptions
  38.           `((name options 
  39.              initargs (options) 
  40.              initform ,(lambda () ()) 
  41.              slot-class ,local-slot-description)))
  42.  
  43.   (deflocal *name* nil)
  44.   (deflocal *readers* nil)
  45.   (deflocal *writers* nil)
  46.   (deflocal *accessors* nil)
  47.   (deflocal *initargs* nil)
  48.  
  49.   (defun reset ()
  50.     (setq *name* nil)
  51.     (setq *readers* nil)
  52.     (setq *writers* nil)
  53.     (setq *accessors* nil)
  54.     (setq *initargs* nil))
  55.  
  56.   (defun canonicalise (ops def-slot-class)
  57.     (when (symbolp ops) (setq ops (list ops)))
  58.     (unless (consp ops) (error "slot options not a list"
  59.                      <Internal-Error> 'options ops))
  60.     (let ((name *nothing*)
  61.       (slot-class def-slot-class)
  62.       (slot-initargs *nothing*)
  63.       (initform *nothing*)
  64.       (initarg nil)
  65.       (readers nil)
  66.       (writers nil)
  67.       (accessors nil))
  68.       (labels
  69.        ((inner (l)
  70.            (unless (null l) 
  71.                (let ((key (car l)) 
  72.                  (val (cadr l)))
  73.              (cond ((eq key 'initarg)
  74.                 (setq initarg (list val)))
  75.                    ((eq key 'initform)
  76.                 (if (eq initform *nothing*)
  77.                     (setq initform `(lambda () ,val))
  78.                   (error "bad initform"
  79.                      invalid-slot-options 'options ops)))
  80.                    ((eq key 'initfunction)
  81.                 (if (eq initform *nothing*)
  82.                     (setq initform val)
  83.                   (error "Initform multiply defined"
  84.                      invalid-slot-options 
  85.                      'options ops)))
  86.                    ((eq key 'slot-class) 
  87.                 (if (eq slot-class def-slot-class)
  88.                     (setq slot-class   val);;do find-dbclass of val
  89.                   (error "slot-class multiply defined"
  90.                      invalid-slot-options 'options ops)))
  91.                    ((eq key 'slot-initargs)
  92.                 (if (eq slot-initargs *nothing*)
  93.                     (setq slot-initargs val);; was class-initargs
  94.                   (error "slot initargs multiply defined"
  95.                      invalid-slot-options 'options ops)))
  96.                    ((eq key 'reader)
  97.                 (setq readers (cons (cons val name) readers)))
  98.                    ((eq key 'writer)
  99.                 (setq writers (cons (cons val name) writers)))
  100.                    ((eq key 'accessor)
  101.                 (setq accessors (cons (cons val name) accessors)))
  102.                    (t (error "unknown slot option"
  103.                      invalid-slot-options 'options ops))))
  104.                (inner (cddr l)))))
  105.        (setq name (car ops))
  106.        (inner (cdr ops))
  107.        (setq *readers* (nconc readers *readers*))
  108.        (setq *writers* (nconc writers *writers*))
  109.        (setq *accessors* (nconc accessors *accessors*))
  110.        (setq *initargs* (nconc initarg *initargs*))
  111.        (when (eq slot-class *nothing*) 
  112.          (setq slot-class '<local-slot-description>))
  113.        (when (eq slot-initargs *nothing*)
  114.          (setq slot-initargs nil))
  115.        (nconc `(list 'name          ',name 
  116.              ,@(if slot-class `('slot-class    ,slot-class ) nil)
  117.              ,@slot-initargs
  118.              ,@(if initarg `('initarg ',(car initarg)) ()))
  119.           (if (eq initform *nothing*)
  120.           `('initfunction ',unbound-slot-value) 
  121.         `('initfunction ,initform))))))
  122.   
  123.   (defun reader-defs (o) 
  124.     (mapcar 
  125.       (lambda (pair) 
  126.     `(defconstant ,(car pair) (find-slot-reader ,*name* ',(cdr pair))))
  127.       *readers*))
  128.  
  129.   (defun writer-defs (o) 
  130.     (mapcar 
  131.       (lambda (pair) 
  132.     `(defconstant ,(car pair) (find-slot-writer ,*name* ',(cdr pair))))
  133.       *writers*))
  134.  
  135.   (defun accessor-defs (o) 
  136.     (mapcar 
  137.       (lambda (pair) 
  138.     `(progn
  139.        (defconstant ,(car pair) (find-slot-reader ,*name* ',(cdr pair)))
  140.        ((setter setter) ,(car pair) (find-slot-writer ,*name* ',(cdr pair)))))
  141.       *accessors*))
  142.  
  143.   (defun make-constructor-initarg-list (ll)
  144.     (if (not (consp ll)) ()
  145.       (cons (list 'quote (car ll))
  146.         (cons (car ll) (make-constructor-initarg-list (cdr ll))))))
  147.  
  148.   (defun improper-list-p (l)
  149.     (if (null (consp l)) l (improper-list-p (cdr l))))
  150.  
  151.   (defun make-positional-constructor-def (spec)
  152.     (let* ((name (car spec))
  153.        (ll (cdr spec))
  154.        (tail (improper-list-p ll)))
  155.       (if (null tail)
  156.     `(defun ,name ,ll
  157.        (make ,*name*
  158.          ,@(make-constructor-initarg-list ll)))
  159.     `(defun ,name ,ll
  160.        (apply
  161.          make
  162.          ,*name*
  163.          (nconc (list ,@(make-constructor-initarg-list ll)) ,tail))))))
  164.     
  165.   (defun constructor-defs (o)
  166.     (cond ((null o) nil)
  167.       ((null (cdr o)) (error "unbalance class ops" 
  168.                  invalid-slot-options 'options o))
  169.       ((eqcar o 'constructor)
  170.         (let ((spec (car (cdr o))))
  171.           (if (atom spec)
  172.         (cons (make-positional-constructor-def (cons spec 'args))
  173.               (constructor-defs (cddr o)))
  174.         (cons (make-positional-constructor-def spec)
  175.               (constructor-defs (cddr o))))))
  176.       ((eqcar o 'predicate)
  177.         (cons `(progn
  178.              (defgeneric ,(car (cdr o)) (obj))
  179.              (defmethod ,(car (cdr o)) ((obj <object>)) ())
  180.              (defmethod ,(car (cdr o)) ((obj ,*name*)) obj))
  181.           (constructor-defs (cddr o))))
  182.       (t (constructor-defs (cddr o)))))
  183.  
  184.   (defun quotify-alternate (l)
  185.     (if (null l) ()
  186.       (cons (list 'quote (car l)) 
  187.         (cons (car (cdr l)) 
  188.           (quotify-alternate (cdr (cdr l)))))))
  189.  
  190.   (defun metaclass-initargs (ops)
  191.     (let ((args (search-key-list ops 'metaclass-initargs)))
  192.       (unless (eq args *key-list-fail*)
  193.     (quotify-alternate args))))
  194.       
  195.   (defmacro defstruct (name super slot-ops . class-ops)
  196.     (reset)
  197.     (setq *name* name)
  198.     `(progn
  199.        (defconstant ,name
  200.      (make <structure-class>
  201.        'name ',name
  202.        'direct-superclasses ,(if super `(list ,super) '(list <structure>)) 
  203.        'direct-slot-descriptions
  204.          (list ,@(mapcar (lambda (x) (canonicalise x '<local-slot-description>))
  205.                  slot-ops))
  206.        'metaclass-hypotheses nil))
  207.        ,@(reader-defs slot-ops)
  208.        ,@(writer-defs slot-ops)
  209.        ,@(accessor-defs slot-ops)
  210.        ,@(constructor-defs class-ops)
  211.        ',name))
  212.  
  213.   (export defstruct)
  214.  
  215.   (defmacro defclass (name supers slot-ops . class-ops)
  216.     (reset)
  217.     (setq *name* name)
  218.     (let ((metaclass
  219.         (or (search-key-list class-ops 'metaclass) '<class>))
  220.       (initargs 
  221.         (or (search-key-list class-ops 'metaclass-initargs) nil))
  222.       (additional-initargs (or (search-key-list class-ops 'direct-initargs) nil))
  223.       (slot-class (search-key-list class-ops 'default-slot-class) ))
  224.       `(progn
  225.      (defconstant ,name
  226.        (make ,metaclass
  227.          'name ',name
  228.          'direct-superclasses ,(if supers `(list ,@supers) '(list <object>))
  229.          'direct-slot-descriptions
  230.          (list ,@(mapcar (lambda (x) (canonicalise x slot-class))
  231.                  slot-ops))
  232.          'metaclass-hypotheses ()
  233.          'direct-initargs ',(append additional-initargs *initargs*)
  234.          ,@(metaclass-initargs class-ops)))
  235.      ,@(reader-defs slot-ops)
  236.      ,@(writer-defs slot-ops)
  237.      ,@(accessor-defs slot-ops)
  238.      ,@(constructor-defs class-ops)
  239.      ',name)))
  240.  
  241.   (export defclass)
  242.  
  243.   (defmacro defreader (name class slot)
  244.     `(defconstant ,name (find-slot-reader ,class ',slot)))
  245.  
  246.   (defmacro defwriter (name class slot)
  247.     `(defconstant ,name (find-slot-writer ,class ',slot)))
  248.  
  249.   (defmacro defaccessor (name class slot)
  250.     `(progn
  251.        (defconstant ,name (find-slot-reader ,class ',slot))
  252.        ((setter setter) ,name (find-slot-writer ,class ',slot))))
  253.  
  254.   (defmacro defpredicate (name class)
  255.     `(progn
  256.        (defgeneric ,name (x))
  257.        (defmethod ,name ((x <object>)) ())
  258.        (defmethod ,name ((x ,class)) x)))
  259.  
  260.   (export defreader defwriter defaccessor defpredicate)
  261.  
  262.   (defun method-extra-args ()
  263.     (if (compile-time-p)
  264.     ()
  265.       (list '***method-status-handle*** '***method-args-handle***)))
  266.  
  267.   (defun sll-signature (ll)
  268.     (cond ((atom ll) nil)
  269.       ((consp (car ll)) (cons (cadar ll) (sll-signature (cdr ll))))
  270.       (t (cons '<object> (sll-signature (cdr ll))))))
  271.  
  272.   (defun sll-formals (ll)
  273.     (cond ((null ll) nil)
  274.       ((atom ll) ll)
  275.       ((consp (car ll)) (cons (caar ll) (sll-formals (cdr ll))))
  276.       (t (cons (car ll) (sll-formals (cdr ll))))))
  277.  
  278.   (defun gf-class (ops)
  279.     (let ((val (search-key-list ops 'class)))
  280.       (if (eq val *key-list-fail*) '<generic-function> val)))
  281.  
  282.   (defun gf-method-class (ops)
  283.     (let ((val (search-key-list ops 'method-class)))
  284.       (if (eq val *key-list-fail*) '<method> val)))
  285.   
  286.   (defun gl-name (ops)
  287.     (let ((val (search-key-list ops 'name)))
  288.       (if (eq val *key-list-fail*) '*unnamed-lambda* val)))
  289.  
  290.   (defun find-method-list (ops)
  291.     (labels ((grab-methods (ops so-far)
  292.                (cond ((null ops) (nreverse so-far))
  293.                  ((eq (car ops) 'method)
  294.                   (grab-methods (cddr ops) (cons (cadr ops) so-far)))
  295.                  (t (grab-methods (cddr ops) so-far)))))
  296.         (let ((meths (search-key-list ops 'methods)))
  297.           (if (eq meths *key-list-fail*) 
  298.           (grab-methods ops nil)
  299.         (nconc (grab-methods ops nil) meths)))))
  300.  
  301.   (defun gf-methods (ops mc)
  302.     (let ((val (find-method-list ops)))
  303.       `(list
  304.     ,@(mapcar
  305.        (lambda (form)
  306.          `(make ,mc
  307.             'signature (list ,@(sll-signature (car form)))
  308.             'function
  309.             (lambda (,@(method-extra-args)
  310.                 ,@(sll-formals (car form)))
  311.               ,@(cdr form)))) 
  312.        val))))
  313.  
  314.   (defmacro defgeneric (name ll . ops)
  315.     `(,@(if (symbolp name) (list 'defconstant name)
  316.       (list `(setter setter) (car (cdr name))))
  317.        (make ,(gf-class ops)
  318.       'name ',name
  319.           'lambda-list ',ll
  320.       'method-class ,(gf-method-class ops)
  321.       'argtype ,(list-length ll)
  322.       'methods ,(gf-methods ops (gf-method-class ops))
  323.       'domain (list ,@(sll-signature ll))
  324.       )))
  325.        
  326.  
  327.   (export defgeneric)
  328.  
  329.   (defmacro defmethod (name sll . body)
  330.     (defmethod-aux `(generic-method-class ,name) nil name sll body))
  331.   
  332.   (defmacro defextmethod (opts name sll . body)
  333.       (let ((class (scan-args 'class opts (default-argument `(generic-method-class ,name) )))
  334.         (opts (quotify-alternate opts)))
  335.     (defmethod-aux class opts name sll body)))
  336.  
  337.   (export defextmethod)
  338.   
  339.  
  340.   (defun defmethod-aux (class opts name sll body)
  341.     `(progn
  342.        (add-method 
  343.     ,name
  344.     (make ,class
  345.           'signature (list ,@(sll-signature sll))
  346.           'argtype ,(length sll)
  347.           'function
  348.           (lambda ,(append (method-extra-args)
  349.                    (sll-formals sll))
  350.         ,@body)
  351.           ,@opts))))
  352.  
  353.   (export defmethod)
  354.  
  355.   (defun defcondition-slot-descriptions (l)
  356.     (if (null l) nil
  357.       (cons `(list 'name ',(car l) 
  358.                'slot-class <local-slot-description>
  359.                    'initargs ',(list (car l))
  360.                    'initform (lambda () ,(cadr l)))
  361.         (defcondition-slot-descriptions (cddr l)))))
  362.  
  363.   (defmacro defcondition (name super . pairs)
  364.     `(defconstant ,name
  365.        (make <condition-class>
  366.           'name ',name
  367.           'direct-superclasses (list ,(if super super '<condition>))
  368.       'direct-slot-descriptions
  369.         (list ,@(defcondition-slot-descriptions pairs)))))
  370.  
  371.   (export defcondition)
  372.  
  373.    (defmacro call-next-method ()
  374.      (if (compile-time-p)
  375.      '(call-method-by-list (method-method-list) 
  376.                  (method-arg-list))
  377.        '(if  ***method-status-handle***
  378.         (progn ;;(format t "Call next: ~a ~a\n"
  379.           ;;***method-status-handle***
  380.           ;;     ***method-args-handle***)
  381.           (apply call-method-by-list
  382.              (list ***method-status-handle***
  383.                ***method-args-handle***)))
  384.       (error "No Next Method" <Internal-Error> nil))))
  385.  
  386.    (defmacro next-method-p ()
  387.      (if (compile-time-p)
  388.      (progn (error "Next-method-p: not implemented" <Internal-Error>)
  389.         nil)
  390.        '***method-status-handle***))
  391.  
  392.    (export next-method-p)
  393.  
  394.   (defmacro generic-lambda (args . ops)
  395.     `(make ,(gf-class ops)
  396.       'name ',(gl-name ops)
  397.           'lambda-list ',args
  398.       'method-class ,(gf-method-class ops)
  399.       'methods ,(gf-methods ops (gf-method-class ops))))
  400.  
  401.   
  402.   (export call-next-method generic-lambda)
  403.  
  404. )
  405.  
  406.